home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 32 / life.zip / LIFE.PAS < prev    next >
Pascal/Delphi Source File  |  1987-09-01  |  3KB  |  134 lines
  1. PROGRAM LIFE(INPUT,OUTPUT);
  2. (*LIFE FORM CREATION PROGRAM*)
  3. (*Code written by Joseph Velasco, August 23, 1987*)
  4. (*Purpose of this program is mainly to aquaint the beginner with Pascal
  5.   Code.
  6.   You may freely distribute and even alter this program at will,
  7.   provided proper credit is given.
  8.   Files: LIFE.PAS --> This program.
  9.          LIFE.DOC --> Brief description and instructions.
  10.          LIFE.EXE --> Compiled PASCAL program.*)
  11.  
  12. CONST
  13.   NUM = 15;
  14. TYPE
  15.   RANGE = 0..NUM;
  16.   ZO = 0..1;
  17. VAR
  18.   LO,L1 : ARRAY[RANGE,RANGE] OF ZO;
  19.   X,Y,R,S,TURN,NADJ : INTEGER;
  20.   SURV : BOOLEAN;
  21.   ADJ : ZO;
  22.   QUIT : BOOLEAN;
  23.   Q : CHAR;
  24. PROCEDURE GOTOXY(X1,Y1:INTEGER);
  25. VAR SX,SY:INTEGER;
  26. BEGIN
  27.   WRITELN(CHR(11));
  28.   FOR SY:= 1 TO Y1 DO
  29.     WRITELN(CHR(31));
  30.   FOR SX := 1 TO X1 DO
  31.     WRITELN(CHR(28));
  32. END;
  33. PROCEDURE HOME;
  34. VAR I : INTEGER;
  35. BEGIN
  36.   FOR I := 1 TO 26 DO
  37.     WRITELN;
  38.   GOTOXY(0,2);
  39. END;
  40. PROCEDURE INITIALIZE;
  41. VAR DATAOK : BOOLEAN;
  42. BEGIN
  43.   HOME;
  44.   SURV := TRUE;
  45.   TURN := 1;
  46.   FOR Y := 1 TO NUM DO
  47.     FOR X := 1 TO NUM DO
  48.       BEGIN
  49.     L1[X,Y] := 0;
  50.     LO[X,Y] := 0;
  51.       END;
  52.   WRITELN('                               **LIFE**');
  53.   WRITELN('                    THE GAME OF EVOLUTIONARY STUDY');
  54.   WRITELN('                      WILL YOUR ORGANISM FLURISH?');
  55.   WRITELN;
  56.   WRITE('NUMBER OF INITIAL CELLS IN ORGANISM? ');
  57.   READLN(R);
  58.   FOR S := 1 TO R DO
  59.     BEGIN
  60.       DATAOK := FALSE;
  61.       REPEAT
  62.     WRITE('PLEASE ENTER THE X <SPACE> Y COORDS. OF THE CELL ',S,': ');
  63.     READLN(X,Y);
  64.     DATAOK := ((Y>0) AND (Y<NUM)) AND ((X>0) AND (X<NUM));            
  65.       UNTIL DATAOK;
  66.       LO[X,Y] := 1;
  67.     END;
  68.   HOME;
  69.   GOTOXY(40,8);
  70.   WRITELN('THE GREAT GAME: *LIFE*');
  71. END;
  72. PROCEDURE COMPUTE;
  73. BEGIN
  74.   SURV := FALSE;
  75.   FOR Y := 1 TO NUM DO
  76.     FOR X := 1 TO NUM DO
  77.       BEGIN
  78.     NADJ := 0;
  79.     FOR R:= -1 TO 1 DO
  80.       FOR S := -1 TO 1 DO
  81.           BEGIN
  82.           IF (R<>0) OR (S<>0) THEN
  83.         IF (X<>1) AND (X<>NUM) AND (Y<>1) AND (Y<>NUM) THEN
  84.           NADJ := NADJ + LO[X+R,Y+S];
  85.         END;
  86.     IF NADJ = 3 THEN L1[X,Y] := 1
  87.        ELSE IF NADJ <> 2 THEN L1[X,Y] := 0;
  88.     IF NOT SURV THEN SURV := (L1[X,Y]=1);
  89.       END;
  90.   FOR Y := 1 TO NUM DO
  91.     FOR X := 1 TO NUM DO
  92.       LO[X,Y] := L1[X,Y];
  93.   TURN := TURN + 1;
  94. END;
  95. PROCEDURE CONSOLE;
  96. BEGIN
  97.   IF TURN > 8 THEN WRITELN('YOUR ORGANISM WAS STRONG, BUT ITS DEAD NOW.')
  98.     ELSE CASE TURN OF
  99.     1,2 : WRITELN('LIFE FORM DEAD.  STICK TO PLAYING WITH LEGO BLOCKS!'); 
  100.     3,4 : WRITELN('LIFE FORM DEAD.  YOU HAVE ONLY YOURSELF TO BLAME.');
  101.     5   : WRITELN('YOU GAVE IT A GOOD SHOT, BUT TAPS IS ITS FINAL SONG.');
  102.     6,7,8 : WRITELN('YOUR CREATION LINGERED FOR QUITE SOME TIME BEFORE IT',
  103.                         ' KICKED THE BUCKET.  GOOD SHOW.');
  104.     END;(*OF CASE*)
  105.     WRITELN('YOUR ORGANISM LASTED ',(TURN-1),' GENERATIONS.');
  106.     WRITELN;
  107. END;
  108. PROCEDURE DISPLAY;
  109. BEGIN
  110.   GOTOXY(0,2);
  111.   FOR Y := 1 TO NUM DO
  112.     BEGIN
  113.       FOR X := 1 TO NUM DO
  114.     IF LO[X,Y] = 1 THEN WRITE('0')
  115.       ELSE WRITE('.');
  116.       WRITELN;
  117.     END;
  118.   WRITELN;WRITELN;WRITELN('GENERATION ',TURN);
  119. END;
  120. BEGIN (*MAIN PROGRAM*)
  121.   REPEAT
  122.     INITIALIZE;
  123.     WHILE SURV DO
  124.       BEGIN
  125.         DISPLAY;
  126.           COMPUTE;
  127.       END;
  128.     CONSOLE;
  129.     WRITE('TRY AGAIN? ');
  130.     READ(Q);
  131.     QUIT := (Q='N') OR (Q='n');
  132.   UNTIL QUIT;
  133. END. (*MAIN PROGRAM*)
  134.